home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tk4.0 / library / palette.tcl < prev    next >
Encoding:
Text File  |  1995-06-08  |  6.9 KB  |  221 lines
  1. # palette.tcl --
  2. #
  3. # This file contains procedures that change the color palette used
  4. # by Tk.
  5. #
  6. # @(#) palette.tcl 1.1 95/05/22 14:55:29
  7. #
  8. # Copyright (c) 1995 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14. # tk_setPalette --
  15. # Changes the default color scheme for a Tk application by setting
  16. # default colors in the option database and by modifying all of the
  17. # color options for existing widgets that have the default value.
  18. #
  19. # Arguments:
  20. # The arguments consist of either a single color name, which
  21. # will be used as the new background color (all other colors will
  22. # be computed from this) or an even number of values consisting of
  23. # option names and values.  The name for an option is the one used
  24. # for the option database, such as activeForeground, not -activeforeground.
  25.  
  26. proc tk_setPalette args {
  27.     global tkPalette
  28.  
  29.     # Create an array that has the complete new palette.  If some colors
  30.     # aren't specified, compute them from other colors that are specified.
  31.  
  32.     if {[llength $args] == 1} {
  33.     set new(background) [lindex $args 0]
  34.     } else {
  35.     array set new $args
  36.     }
  37.     if ![info exists new(background)] {
  38.     error "must specify a background color"
  39.     }
  40.     if ![info exists new(foreground)] {
  41.     set new(foreground) black
  42.     }
  43.     set bg [winfo rgb . $new(background)]
  44.     set fg [winfo rgb . $new(foreground)]
  45.     set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \
  46.         [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]]
  47.     foreach i {activeForeground insertBackground selectForeground \
  48.         highlightColor} {
  49.     if ![info exists new($i)] {
  50.         set new($i) $new(foreground)
  51.     }
  52.     }
  53.     if ![info exists new(disabledForeground)] {
  54.     set new(disabledForeground) [format #%02x%02x%02x \
  55.         [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \
  56.         [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \
  57.         [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]]
  58.     }
  59.     if ![info exists new(highlightBackground)] {
  60.     set new(highlightBackground) $new(background)
  61.     }
  62.     if ![info exists new(activeBackground)] {
  63.     # Pick a default active background that islighter than the
  64.     # normal background.  To do this, round each color component
  65.     # up by 15% or 1/3 of the way to full white, whichever is
  66.     # greater.
  67.  
  68.     foreach i {0 1 2} {
  69.         set light($i) [expr [lindex $bg $i]/256]
  70.         set inc1 [expr ($light($i)*15)/100]
  71.         set inc2 [expr (255-$light($i))/3]
  72.         if {$inc1 > $inc2} {
  73.         incr light($i) $inc1
  74.         } else {
  75.         incr light($i) $inc2
  76.         }
  77.         if {$light($i) > 255} {
  78.         set light($i) 255
  79.         }
  80.     }
  81.     set new(activeBackground) [format #%02x%02x%02x $light(0) \
  82.         $light(1) $light(2)]
  83.     }
  84.     if ![info exists new(selectBackground)] {
  85.     set new(selectBackground) $darkerBg
  86.     }
  87.     if ![info exists new(troughColor)] {
  88.     set new(troughColor) $darkerBg
  89.     }
  90.     if ![info exists new(selectColor)] {
  91.     set new(selectColor) #b03060
  92.     }
  93.  
  94.     # Walk the widget hierarchy, recoloring all existing windows.
  95.     # Before doing this, make sure that the tkPalette variable holds
  96.     # the default values of all options, so that tkRecolorTree can
  97.     # be sure to only change options that have their default values.
  98.     # If the variable exists, then it is already correct (it was created
  99.     # the last time this procedure was invoked).  If the variable
  100.     # doesn't exist, fill it in using the defaults from a few widgets.
  101.  
  102.     if ![info exists tkPalette] {
  103.     checkbutton .c14732
  104.     entry .e14732
  105.     scrollbar .s14732
  106.     set tkPalette(activeBackground) \
  107.         [lindex [.c14732 configure -activebackground] 3]
  108.     set tkPalette(activeForeground) \
  109.         [lindex [.c14732 configure -activeforeground] 3]
  110.     set tkPalette(background) \
  111.         [lindex [.c14732 configure -background] 3]
  112.     set tkPalette(disabledForeground) \
  113.         [lindex [.c14732 configure -disabledforeground] 3]
  114.     set tkPalette(foreground) \
  115.         [lindex [.c14732 configure -foreground] 3]
  116.     set tkPalette(highlightBackground) \
  117.         [lindex [.c14732 configure -highlightbackground] 3]
  118.     set tkPalette(highlightColor) \
  119.         [lindex [.c14732 configure -highlightcolor] 3]
  120.     set tkPalette(insertBackground) \
  121.         [lindex [.e14732 configure -insertbackground] 3]
  122.     set tkPalette(selectColor) \
  123.         [lindex [.c14732 configure -selectcolor] 3]
  124.     set tkPalette(selectBackground) \
  125.         [lindex [.e14732 configure -selectbackground] 3]
  126.     set tkPalette(selectForeground) \
  127.         [lindex [.e14732 configure -selectforeground] 3]
  128.     set tkPalette(troughColor) \
  129.         [lindex [.s14732 configure -troughcolor] 3]
  130.     destroy .c14732 .e14732 .s14732
  131.     }
  132.     tkRecolorTree . new
  133.  
  134.     # Change the option database so that future windows will get the
  135.     # same colors.
  136.  
  137.     foreach option [array names new] {
  138.     option add *$option $new($option) widgetDefault
  139.     }
  140.  
  141.     # Save the options in the global variable tkPalette, for use the
  142.     # next time we change the options.
  143.  
  144.     array set tkPalette [array get new]
  145. }
  146.  
  147. # tkRecolorTree --
  148. # This procedure changes the colors in a window and all of its
  149. # descendants, according to information provided by the colors
  150. # argument.  It only modifies colors that have their default values
  151. # as specified by the tkPalette variable.
  152. #
  153. # Arguments:
  154. # w -            The name of a window.  This window and all its
  155. #            descendants are recolored.
  156. # colors -        The name of an array variable in the caller,
  157. #            which contains color information.  Each element
  158. #            is named after a widget configuration option, and
  159. #            each value is the value for that option.
  160.  
  161. proc tkRecolorTree {w colors} {
  162.     global tkPalette
  163.     upvar $colors c
  164.     foreach dbOption [array names c] {
  165.     set option -[string tolower $dbOption]
  166.     if ![catch {$w cget $option} value] {
  167.         if {$value == $tkPalette($dbOption)} {
  168.         $w configure $option $c($dbOption)
  169.         }
  170.     }
  171.     }
  172.     foreach child [winfo children $w] {
  173.     tkRecolorTree $child c
  174.     }
  175. }
  176.  
  177. # tkDarken --
  178. # Given a color name, computes a new color value that darkens (or
  179. # brightens) the given color by a given percent.
  180. #
  181. # Arguments:
  182. # color -    Name of starting color.
  183. # perecent -    Integer telling how much to brighten or darken as a
  184. #        percent: 50 means darken by 50%, 110 means brighten
  185. #        by 10%.
  186.  
  187. proc tkDarken {color percent} {
  188.     set l [winfo rgb . $color]
  189.     set red [expr [lindex $l 0]/256]
  190.     set green [expr [lindex $l 1]/256]
  191.     set blue [expr [lindex $l 2]/256]
  192.     set red [expr ($red*$percent)/100]
  193.     if {$red > 255} {
  194.     set red 255
  195.     }
  196.     set green [expr ($green*$percent)/100]
  197.     if {$green > 255} {
  198.     set green 255
  199.     }
  200.     set blue [expr ($blue*$percent)/100]
  201.     if {$blue > 255} {
  202.     set blue 255
  203.     }
  204.     format #%02x%02x%02x $red $green $blue
  205. }
  206.  
  207. # tk_bisque --
  208. # Reset the Tk color palette to the old "bisque" colors.
  209. #
  210. # Arguments:
  211. # None.
  212.  
  213. proc tk_bisque {} {
  214.     tk_setPalette activeBackground #e6ceb1 activeForeground black \
  215.         background #ffe4c4 disabledForeground #b0b0b0 foreground black \
  216.         highlightBackground #ffe4c4 highlightColor black \
  217.         insertBackground black selectColor #b03060 \
  218.         selectBackground #e6ceb1 selectForeground black \
  219.         troughColor #cdb79e
  220. }
  221.